home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / macros1.lsp < prev    next >
Encoding:
Text File  |  1993-06-05  |  18.0 KB  |  519 lines
  1. ;;;; Definitionen für Kontrollstrukturen etc.
  2. ;;;; 29. 4. 1988, 3. 9. 1988
  3.  
  4. (in-package "LISP")
  5. (export '(mapcap maplap))
  6. (in-package "SYSTEM")
  7.  
  8. (defmacro defvar (symbol &optional (initial-value nil svar) docstring)
  9.   (unless (symbolp symbol)
  10.     (error #+DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  11.            #+ENGLISH "~S: non-symbol ~S can't be a variable"
  12.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S"
  13.            'defvar symbol
  14.   ) )
  15.   (if (constantp symbol)
  16.     (error #+DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  17.            #+ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  18.            #+FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  19.            'defvar symbol
  20.   ) )
  21.   `(PROGN
  22.      (PROCLAIM '(SPECIAL ,symbol))
  23.      ,@(if svar
  24.          `((UNLESS (BOUNDP ',symbol) (SET ',symbol ,initial-value)))
  25.        )
  26.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  27.      ',symbol
  28.    )
  29. )
  30.  
  31. (defmacro defparameter (symbol initial-value &optional docstring)
  32.   (unless (symbolp symbol)
  33.     (error #+DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  34.            #+ENGLISH "~S: non-symbol ~S can't be a variable"
  35.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S."
  36.            'defparameter symbol
  37.   ) )
  38.   (if (constantp symbol)
  39.     (error #+DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  40.            #+ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  41.            #+FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  42.            'defparameter symbol
  43.   ) )
  44.   `(PROGN
  45.      (PROCLAIM '(SPECIAL ,symbol))
  46.      (SET ',symbol ,initial-value)
  47.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  48.      ',symbol
  49.    )
  50. )
  51.  
  52. (defmacro defconstant (&whole form symbol initial-value &optional docstring)
  53.   (unless (symbolp symbol)
  54.     (error #+DEUTSCH "~S: Nur Symbole können als Konstanten definiert werden, nicht ~S"
  55.            #+ENGLISH "~S: non-symbol ~S can't be a defined constant"
  56.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de constante et non ~S."
  57.            'defconstant symbol
  58.   ) )
  59.   `(PROGN
  60.      (EVAL-WHEN (COMPILE)
  61.        (COMPILER::C-PROCLAIM-CONSTANT ',symbol ',initial-value)
  62.      )
  63.      (IF (CONSTANTP ',symbol)
  64.        (WARN #+DEUTSCH "In ~S wird die Konstante ~S umdefiniert. Ihr alter Wert war ~S."
  65.              #+ENGLISH "~S redefines the constant ~S. Its old value was ~S."
  66.              #+FRANCAIS "~S redéfinit la constante ~S. Son ancienne valeur était ~S."
  67.              ',form ',symbol (SYMBOL-VALUE ',symbol)
  68.      ) )
  69.      (SYS::%PROCLAIM-CONSTANT ',symbol ,initial-value)
  70.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  71.      ',symbol
  72.    )
  73. )
  74.  
  75. (sys::%put 'and 'sys::macro
  76.   (sys::macro-expander and (&body args)
  77.     (cond ((null args) T)
  78.           ((null (cdr args)) (car args))
  79.           (t (let ((L (mapcar #'(lambda (x) `((NOT ,x) NIL) ) args)))
  80.                (rplaca (last L) `(T ,(car (last args))))
  81.                (cons 'COND L)
  82.   ) )     )  )
  83. )
  84.  
  85. (sys::%put 'or 'sys::macro
  86.   (sys::macro-expander or (&body args)
  87.     (cond ((null args) NIL)
  88.           ((null (cdr args)) (car args))
  89.           (t (let ((L (mapcar #'list args)))
  90.                (rplaca (last L) `(T ,(car (last args))))
  91.                (cons 'COND L)
  92.   ) )     )  )
  93. )
  94.  
  95. (sys::%put 'prog1 'sys::macro
  96.   (sys::macro-expander prog1 (form1 &rest moreforms)
  97.     (let ((g (gensym)))
  98.       `(LET ((,g ,form1)) ,@moreforms ,g)
  99.   ) )
  100. )
  101.  
  102. (sys::%put 'prog2 'sys::macro
  103.   (sys::macro-expander prog2 (form1 form2 &rest moreforms)
  104.     (let ((g (gensym)))
  105.       `(PROGN ,form1 (LET ((,g ,form2)) ,@moreforms ,g))
  106.   ) )
  107. )
  108.  
  109. (sys::%put 'when 'sys::macro
  110.   (sys::macro-expander when (test &body forms)
  111.     `(IF ,test (PROGN ,@forms))
  112.   )
  113. )
  114.  
  115. (sys::%put 'unless 'sys::macro
  116.   (sys::macro-expander unless (test &body forms)
  117.     `(IF (NOT ,test) (PROGN ,@forms))
  118.   )
  119. )
  120.  
  121. (defmacro return (&optional return-value)
  122.   `(RETURN-FROM NIL ,return-value)
  123. )
  124.  
  125. (defmacro loop (&body body)
  126.   (let ((tag (gensym)))
  127.     `(BLOCK NIL (TAGBODY ,tag ,@body (GO ,tag)))
  128. ) )
  129.  
  130. (defun do/do*-expand (varclauselist exitclause body env do let psetq)
  131.   (when (atom exitclause)
  132.     (error #+DEUTSCH "Exitclause in ~S muß Liste sein."
  133.            #+ENGLISH "exit clause in ~S must be a list"
  134.            #+FRANCAIS "La clause de sortie dans ~S doit être une liste."
  135.            do
  136.   ) )
  137.   (let ((bindlist nil)
  138.         (reinitlist nil)
  139.         (testtag (gensym))
  140.         (exittag (gensym)))
  141.     (multiple-value-bind (body-rest declarations doc)
  142.                          (sys::parse-body body nil env)
  143.       (declare (ignore doc))
  144.       (if declarations
  145.         (setq declarations (list (cons 'DECLARE declarations)))
  146.       )
  147.       (loop
  148.         (when (atom varclauselist) (return))
  149.         (let ((varclause (first varclauselist)))
  150.           (setq varclauselist (rest varclauselist))
  151.           (cond ((atom varclause)
  152.                  (setq bindlist (cons varclause bindlist))
  153.                 )
  154.                 ((atom (cdr varclause))
  155.                  (setq bindlist (cons (first varclause) bindlist))
  156.                 )
  157.                 ((atom (cddr varclause))
  158.                  (setq bindlist (cons varclause bindlist))
  159.                 )
  160.                 (t (setq bindlist
  161.                      (cons (list (first varclause) (second varclause))
  162.                            bindlist
  163.                    ) )
  164.                    (setq reinitlist
  165.                      (list* (third varclause) (first varclause) reinitlist)
  166.       ) ) )     )  )
  167.       `(BLOCK NIL
  168.          (,let ,(nreverse bindlist)
  169.            ,@declarations
  170.            (TAGBODY
  171.              ,testtag
  172.              (IF ,(first exitclause) (GO ,exittag))
  173.              ,@body-rest
  174.              (,psetq ,@(nreverse reinitlist))
  175.              (GO ,testtag)
  176.              ,exittag
  177.              (RETURN-FROM NIL (PROGN ,@(rest exitclause)))
  178.        ) ) )
  179. ) ) )
  180.  
  181. (fmakunbound 'do)
  182. (defmacro do (varclauselist exitclause &body body &environment env)
  183.   (do/do*-expand varclauselist exitclause body env 'DO 'LET 'PSETQ)
  184. )
  185.  
  186. (defmacro do* (varclauselist exitclause &body body &environment env)
  187.   (do/do*-expand varclauselist exitclause body env 'DO* 'LET* 'SETQ)
  188. )
  189.  
  190. (defmacro dolist ((var listform &optional resultform) &body body &environment env)
  191.   (multiple-value-bind (body-rest declarations)
  192.                        (sys::parse-body body nil env)
  193.     (let ((g (gensym)))
  194.       `(DO* ((,g ,listform (CDR ,g))
  195.              (,var NIL))
  196.             ((ENDP ,g)
  197.              ,(if (constantp resultform)
  198.                ; Ist resultform konstant, so ist es /= var. Daher braucht var
  199.                ; während Auswertung von resultform nicht an NIL gebunden zu sein:
  200.                `,resultform
  201.                `(LET ((,var NIL))
  202.                   ,@(if declarations (list (cons 'DECLARE declarations)))
  203.                   ,var ; var wird nur zum Schein ausgewertet
  204.                   ,resultform
  205.                 )
  206.               )
  207.             )
  208.          (DECLARE (LIST ,g) ,@declarations)
  209.          (SETQ ,var (CAR ,g))
  210.          ,@body-rest
  211.        )
  212. ) ) )
  213.  
  214. (fmakunbound 'dotimes)
  215. (defmacro dotimes ((var countform &optional resultform) &body body &environment env)
  216.   (multiple-value-bind (body-rest declarations)
  217.                        (sys::parse-body body nil env)
  218.     (if declarations
  219.       (setq declarations (list (cons 'DECLARE declarations)))
  220.     )
  221.     (if (constantp countform)
  222.       `(DO ((,var 0 (1+ ,var)))
  223.            ((>= ,var ,countform) ,resultform)
  224.          ,@declarations
  225.          ,@body-rest
  226.        )
  227.       (let ((g (gensym)))
  228.         `(DO ((,var 0 (1+ ,var))
  229.               (,g ,countform))
  230.              ((>= ,var ,g) ,resultform)
  231.            ,@declarations
  232.            ,@body-rest
  233. ) ) ) )  )
  234.  
  235. (sys::%put 'psetq 'sys::macro
  236.   (sys::macro-expander psetq (&whole form &rest args)
  237.     (do* ((setlist nil)
  238.           (bindlist nil)
  239.           (arglist args (cddr arglist)))
  240.          ((null arglist)
  241.           (setq setlist (cons 'NIL setlist))
  242.           (cons 'LET (cons (nreverse bindlist) (nreverse setlist)))
  243.          )
  244.       (if (null (cdr arglist))
  245.         (error #+DEUTSCH "~S mit einer ungeraden Anzahl von Argumenten aufgerufen: ~S"
  246.                #+ENGLISH "~S called with an odd number of arguments: ~S"
  247.                #+FRANCAIS "~S fut appellé avec un nombre impair d'arguments : ~S"
  248.                'psetq form
  249.       ) )
  250.       (let ((g (gensym)))
  251.         (setq setlist (cons `(SETQ ,(first arglist) ,g) setlist))
  252.         (setq bindlist (cons `(,g ,(second arglist)) bindlist))
  253.   ) ) )
  254. )
  255.  
  256. (sys::%put 'multiple-value-list 'sys::macro
  257.   (sys::macro-expander multiple-value-list (form)
  258.     `(MULTIPLE-VALUE-CALL #'LIST ,form)
  259.   )
  260. )
  261.  
  262. (sys::%put 'multiple-value-bind 'sys::macro
  263.   (sys::macro-expander multiple-value-bind (varlist form &body body)
  264.     (let ((g (gensym))
  265.           (poplist nil))
  266.       (dolist (var varlist) (setq poplist (cons `(,var (POP ,g)) poplist)))
  267.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)) ,@(nreverse poplist))
  268.          ,@body
  269.   ) )  )
  270. )
  271.  
  272. (sys::%put 'multiple-value-setq 'sys::macro
  273.   (sys::macro-expander multiple-value-setq (varlist form)
  274.     (let ((g (gensym))
  275.           (poplist nil))
  276.       (dolist (var varlist) (setq poplist (cons `(SETQ ,var (POP ,g)) poplist)))
  277.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)))
  278.          ,(if poplist `(PROG1 ,(nreverse poplist)) NIL)
  279.   ) )  )
  280. )
  281.  
  282. (defmacro locally (&body body)
  283.   `(LET () ,@body)
  284. )
  285.  
  286. (defmacro case (keyform &body body)
  287.            ;; Common LISP, S. 117
  288.   (let ((var (gensym)))
  289.     `(LET ((,var ,keyform))
  290.        (COND
  291.          ,@(mapcar
  292.              #'(lambda (cl)
  293.                  (unless (consp cl)
  294.                    (error #+DEUTSCH "~S: Keylist fehlt."
  295.                           #+ENGLISH "~S: missing key list"
  296.                           #+FRANCAIS "~S : la liste d'objects-clé manque."
  297.                           'case
  298.                  ) )
  299.                  (let ((kl (first cl)))
  300.                    `(,(cond ((or (eq kl 'T) (eq kl 'OTHERWISE)) 'T)
  301.                             ((listp kl) `(MEMBER ,var ',kl))
  302.                             (t `(EQL ,var ',kl))
  303.                       )
  304.                      ,@(rest cl)
  305.                ) )  )
  306.              body
  307. ) )  ) )   )
  308.  
  309. (defmacro prog (varlist &body body &environment env)
  310.   (multiple-value-bind (body-rest declarations)
  311.                        (sys::parse-body body nil env)
  312.     (if declarations
  313.       (setq declarations (list (cons 'DECLARE declarations)))
  314.     )
  315.     `(BLOCK NIL
  316.        (LET ,varlist
  317.          ,@declarations
  318.          (TAGBODY ,@body-rest)
  319. ) )  ) )
  320.  
  321. (defmacro prog* (varlist &body body &environment env)
  322.   (multiple-value-bind (body-rest declarations)
  323.                        (sys::parse-body body nil env)
  324.     (if declarations
  325.       (setq declarations (list (cons 'DECLARE declarations)))
  326.     )
  327.     `(BLOCK NIL
  328.        (LET* ,varlist
  329.          ,@declarations
  330.          (TAGBODY ,@body-rest)
  331. ) )  ) )
  332.  
  333.  
  334. ;;; Macro-Expander für COND:
  335.  
  336. #|
  337. ;; Dieser hier ist zwar kürzer, aber er reduziert COND auf OR,
  338. ;; das seinerseits wieder auf COND reduziert, ...
  339. (sys::%put 'cond 'sys::macro
  340.   (sys::macro-expander cond (&body clauses)
  341.     (ifify clauses)
  342.   )
  343. )
  344. ; macht eine clauselist von COND zu verschachtelten IFs und ORs.
  345. (defun ifify (clauselist)
  346.   (cond ((null clauselist) NIL)
  347.         ((atom clauselist)
  348.          (error #+DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  349.                 #+ENGLISH "Not a list of COND clauses: ~S"
  350.                 #+FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  351.                 clauselist
  352.         ))
  353.         ((atom (car clauselist))
  354.          (error #+DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  355.                 #+ENGLISH "The atom ~S must not be used as a COND clause."
  356.                 #+FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  357.                 (car clauselist)
  358.         ))
  359.         (t (let ((ifif (ifify (cdr clauselist))))
  360.              (if (cdar clauselist)
  361.                ; mindestens zweielementige Klausel
  362.                (if (constantp (caar clauselist))
  363.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  364.                    (if (cddar clauselist)
  365.                      `(PROGN ,@(cdar clauselist))
  366.                      (cadar clauselist)
  367.                    )
  368.                    ifif
  369.                  )
  370.                  `(IF ,(caar clauselist)
  371.                     ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  372.                     ,ifif
  373.                   )
  374.                )
  375.                ; einelementige Klausel
  376.                (if (constantp (caar clauselist))
  377.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  378.                    (caar clauselist)
  379.                    ifif
  380.                  )
  381.                  `(OR ,(caar clauselist) ,ifif)
  382. ) )     )  ) ) )
  383. |#
  384.  
  385. ;; Noch einfacher ginge es auch so:
  386. #|
  387. (sys::%put 'cond 'sys::macro
  388.   (sys::macro-expander cond (&body clauses)
  389.     (cond ((null clauses) 'NIL)
  390.           ((atom clauses)
  391.            (error #+DEUTSCH "Dotted List im Code von COND, endet mit ~S"
  392.                   #+ENGLISH "COND code contains a dotted list, ending with ~S"
  393.                   #+FRANCAIS "Occurence d'une paire pointée dans le code de COND, terminée en : ~S."
  394.                   clauses
  395.           ))
  396.           (t (let ((clause (car clauses)))
  397.                (if (atom clause)
  398.                  (error #+DEUTSCH "COND-Klausel ohne Test: ~S"
  399.                         #+ENGLISH "COND clause without test: ~S"
  400.                         #+FRANCAIS "Clause COND sans aucun test : ~S"
  401.                         clause
  402.                  )
  403.                  (let ((test (car clause)))
  404.                    (if (cdr clause)
  405.                      `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  406.                      `(OR ,test (COND ,@(cdr clauses)))
  407. ) ) )     )  ) ) ) )
  408. |#
  409.  
  410. ;; Dieser hier reduziert COND etwas umständlicher auf IF-Folgen:
  411. (sys::%put 'cond 'sys::macro
  412.   (sys::macro-expander cond (&body clauses)
  413.     (let ((g (gensym)))
  414.       (multiple-value-bind (ifif needed-g) (ifify clauses g)
  415.         (if needed-g
  416.           `(LET (,g) ,ifif)
  417.           ifif
  418.   ) ) ) )
  419. )
  420. ; macht eine clauselist von COND zu verschachtelten IFs.
  421. ; Zwei Werte: die neue Form, und ob die Dummyvariable g benutzt wurde.
  422. (defun ifify (clauselist g)
  423.   (cond ((null clauselist) (values NIL nil))
  424.         ((atom clauselist)
  425.          (error #+DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  426.                 #+ENGLISH "Not a list of COND clauses: ~S"
  427.                 #+FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  428.                 clauselist
  429.         ))
  430.         ((atom (car clauselist))
  431.          (error #+DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  432.                 #+ENGLISH "The atom ~S must not be used as a COND clause."
  433.                 #+FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  434.                 (car clauselist)
  435.         ))
  436.         (t (multiple-value-bind (ifif needed-g) (ifify (cdr clauselist) g)
  437.              (if (cdar clauselist)
  438.                ; mindestens zweielementige Klausel
  439.                (if (constantp (caar clauselist))
  440.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  441.                    (if (cddar clauselist)
  442.                      (values `(PROGN ,@(cdar clauselist)) nil)
  443.                      (values (cadar clauselist) nil)
  444.                    )
  445.                    (values ifif needed-g)
  446.                  )
  447.                  (values
  448.                    `(IF ,(caar clauselist)
  449.                         ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  450.                         ,ifif
  451.                     )
  452.                    needed-g
  453.                ) )
  454.                ; einelementige Klausel
  455.                (if (constantp (caar clauselist))
  456.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  457.                    (values (caar clauselist) nil)
  458.                    (values ifif needed-g)
  459.                  )
  460.                  (if (atom (caar clauselist))
  461.                    (values ; ein Atom produziert nur einen Wert und darf
  462.                      `(IF ,(caar clauselist) ; mehrfach hintereinander
  463.                           ,(caar clauselist) ; ausgewertet werden!
  464.                           ,ifif
  465.                       )
  466.                      needed-g
  467.                    )
  468.                    (values
  469.                      `(IF (SETQ ,g ,(caar clauselist)) ,g ,ifif)
  470.                      t
  471. ) )     )  ) ) ) ) )
  472.  
  473. ;;; Mapping (Kapitel 7.8.4)
  474.  
  475. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  476. ; (mapcap fun &rest lists) ==  (apply #'append (apply #'mapcar fun lists))
  477. (defun mapcap (fun &rest lists &aux (L nil))
  478.   (loop
  479.     (setq L
  480.       (nconc
  481.         (reverse
  482.           (apply fun
  483.             (maplist #'(lambda (listsr)
  484.                          (if (atom (car listsr))
  485.                            (return)
  486.                            (pop (car listsr))
  487.                        ) )
  488.                      lists
  489.         ) ) )
  490.         L
  491.       )
  492.   ) )
  493.   (sys::list-nreverse L)
  494. )
  495.  
  496. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  497. ; (maplap fun &rest lists) == (apply #'append (apply #'maplist fun lists))
  498. (defun maplap (fun &rest lists &aux (L nil))
  499.   (loop
  500.     (setq L
  501.       (nconc
  502.         (reverse
  503.           (apply fun
  504.             (maplist #'(lambda (listsr)
  505.                          (if (atom (car listsr))
  506.                            (return)
  507.                            (prog1
  508.                              (car listsr)
  509.                              (setf (car listsr) (cdr (car listsr)))
  510.                        ) ) )
  511.                      lists
  512.         ) ) )
  513.         L
  514.       )
  515.   ) )
  516.   (sys::list-nreverse L)
  517. )
  518.  
  519.